home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / prot100.zip / MODEM.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-19  |  8KB  |  294 lines
  1. Program Modem7;
  2. {
  3.    Written: 05-19-90
  4.    Revised: 12-27-92
  5.    Copyright (c)1990,1992, Eric J. Givler, All Rights Reserved.
  6. }
  7. USES Ansi_Drv,
  8.      Dos,
  9.      Crt,
  10.      CRCS,        { CRCS is a host of crc calculation routines }
  11.      FOS,         { Fossil Communications primitives }
  12.      protocol;    { Protocol Unit }
  13.  
  14.  
  15. CONST
  16.       COMport = 1;
  17.       NUL = #$00;  { a # means character instead of byte, ie #$01 }
  18.       SOH = #$01;
  19.       STX = #$02;
  20.       EOT = #$04;
  21.       ACK = #$06;
  22.       NAK = #$15;
  23.       XON = #$11;
  24.       XOFF = #$13;
  25.       CPMEOF = #$1A;
  26.  
  27.       CAN = #$18;
  28.       C   = #$43;
  29.       TAB = #$09;
  30.       LF  = #$0A; {character}
  31.       CR  = #$0D; {character}
  32.       SPACE = #$20;
  33.       DELete = #$7F;
  34.       lastbyte = 127;
  35.       errormax = 5;
  36.       retrymax = 5;
  37.  
  38. TYPE  maxstr  = string;
  39.       hexstr  = string[4];
  40.       blocktype = array[0..127] of byte;
  41.  
  42. VAR  Screen : Text;
  43.      WorkFile: file;
  44.      option,
  45.      hangup,
  46.      return,
  47.      mode : char;
  48.      baudrate : longint;
  49.      sector : blocktype;        { array[0..lastbyte] of byte; }
  50.      rcvbuf : blocktype;        { array[0..127] of byte;      }
  51.      inptr,
  52.      outptr: integer;
  53.  
  54.      dt : DateTime;
  55.      { regs :registers;
  56.      portnum : word; }
  57.  
  58. (*
  59.    ================================================================
  60.                      FUNCTIONS and PROCEDURES follow.
  61.    ================================================================
  62. PROCEDURE GetOption         - draws menu and gets user terminal option.
  63. PROCEDURE ReceiveFile       - Receive a File (main)
  64. PROCEDURE ReceiveIt         - Receive a File - Xmodem/Checksum
  65. PROCEDURE SendFile          - Send a File - MAIN menu system.
  66. PROCEDURE SendAscii         - Send a File - Ascii with XON/XOFF
  67. PROCEDURE SendCRC           - Send a File - Xmodem/CRC
  68. PROCEDURE SendMEGALink      - Send a File - MEGALINK
  69. PROCEDURE Terminal          - SIMPLE terminal.
  70. *)
  71.  
  72.  
  73. PROCEDURE SendFile;
  74. VAR j,
  75.     blocknum,
  76.     counter,
  77.     result,
  78.     checksum : integer;
  79.     filename : string;
  80.     c : char;
  81.     success : boolean;
  82.  
  83. (* {$I ASCIIS }   { Ascii Send           - SendAscii    } *)
  84. (* {$I MEGALS }   { MegaLink Send        - SendMEGALink } *)
  85. (* {$I YMGS }     { Ymodem-G Send        - SendYmodem_G } *)
  86.  
  87. BEGIN
  88.   Write('Filename.Ext ? ');
  89.   ReadLn(filename);
  90.   IF Length(filename) > 0 THEN
  91.   begin
  92.      Write('X)modem/chksum,Xmodem(C)rc,(1)KXmdm,(Y)modem: ');
  93.      readln(c); { repeat until keypressed; }
  94.      c := upcase(c);
  95.      case c of
  96.         {'A' : SendAscii;}
  97.         'X' : success := Upload( filename, XmodemChkSum );
  98.         'C' : success := Upload( filename, XmodemCRC );
  99.         '1' : success := Upload( filename, Xmodem1K );
  100.         'Y' : success := Upload( filename, Ymodem );
  101.      else
  102.        writeln('Invalid protocol [',c,'] selected.');
  103.      end;
  104.   end;
  105. end;
  106.  
  107.  
  108. PROCEDURE ReceiveFile;
  109.   VAR j,
  110.       firstchar,
  111.       sectornum,
  112.       sectorcurrent,
  113.       sectorcomp,
  114.       errors,
  115.       checksum  : integer;
  116.       errorflag : boolean;
  117.       filename  : string[20];
  118.       c         : char;
  119.  
  120. (* {$I ASCIIR }   { Receive Ascii module } *)
  121.  
  122. (*
  123.   PROCEDURE ReceiveIt;
  124.     VAR  j : integer;
  125.     BEGIN
  126.       sectornum := 0;
  127.       errors := 0;
  128.       Send(NAK);
  129.       Send(NAK);                       { send ready characters }
  130.       REPEAT
  131.         errorflag := false;
  132.         REPEAT
  133.           firstchar := readline(20);
  134.         UNTIL ((firstchar IN [Ord(SOH),Ord(EOT)]) OR (firstchar = timeout));
  135.         IF firstchar = timeout THEN Writeln(cr,lf,'Error - No starting SOH');
  136.         IF firstchar = Ord(SOH) THEN BEGIN
  137.            sectorcurrent := Readline(1);      {real sector number}
  138.            sectorcomp := Readline(1);         {+ inverse of above}
  139.            IF (sectorcurrent+sectorcomp) = 255 THEN BEGIN {< becomes this #}
  140.              IF (sectorcurrent=sectornum+1) THEN BEGIN
  141.                 checksum := 0;
  142.                 FOR j := 0 TO lastbyte DO BEGIN
  143.                    sector[j] := Readline(1);
  144.                    checksum := (checksum+sector[j]) AND $00FF
  145.                 END;
  146.                 IF checksum = Readline(1) THEN BEGIN
  147.                    Blockwrite(WorkFile,sector,1);
  148.                    errors := 0;
  149.                    sectornum := sectorcurrent;
  150.                    Write(cr,'Received sector ',sectorcurrent);
  151.                    Send(ACK)
  152.                 END ELSE BEGIN
  153.                    Writeln(cr,lf,'Checksum error');
  154.                    errorflag := true
  155.                 END
  156.              END ELSE IF (sectorcurrent=sectornum) THEN BEGIN
  157.                 REPEAT
  158.                 UNTIL Readline(1) = timeout;
  159.                 Writeln(cr,lf,'Received duplicate sector ', sectorcurrent);
  160.                 Send(ack)
  161.              END ELSE BEGIN
  162.                 Writeln(cr,lf,'Synchronization error');
  163.                 errorflag := true
  164.              END
  165.            END else BEGIN
  166.              Writeln(cr,lf,'Sector number error');
  167.              errorflag := true
  168.            END
  169.         END;
  170.         IF errorflag THEN BEGIN
  171.            inc(errors);
  172.            REPEAT
  173.            UNTIL Readline(1) = timeout;
  174.            Send(nak)
  175.         END;
  176.       UNTIL ((firstchar = Ord(EOT)) OR (firstchar = timeout)) OR
  177.             (errors = errormax) OR (NOT Carrier);
  178.       IF (firstchar = Ord(EOT)) AND (errors < errormax) THEN BEGIN
  179.          Send(ack);
  180.          Writeln(cr,lf,'Transfer complete')
  181.       END
  182.          ELSE Writeln(cr,lf,'Aborting');
  183.     END;
  184. *)
  185.  
  186. BEGIN
  187.   Write('Filename.Ext? ');
  188.   Readln(filename);
  189.   IF length(filename) > 0 then begin
  190.      Write('Protocol: a)scii, x)modem: ');
  191.      repeat until keypressed;
  192.      c := upcase(readkey);
  193.      CASE c of
  194.       'a' : {}
  195.       (*   'A' : RecvAscii(filename); *)
  196.       {  'X' : begin
  197.                 Assign(WorkFile,filename);
  198.                 Rewrite(WorkFile);
  199.                 ReceiveIt;
  200.                 Close(WorkFile);
  201.               end;}
  202.      else
  203.         writeln(c,' is not a valid protocol.');
  204.      end;
  205.   END;
  206. END;
  207.  
  208.  
  209. PROCEDURE PortChange;
  210. var port : integer;
  211. begin
  212.    Write('Enter port #: ');
  213.    ReadLn(port);
  214.    CloseFossil;
  215.    PortNum := Port;
  216.    IF NOT OpenFossil THEN Exit;
  217. end;
  218.  
  219.  
  220. PROCEDURE terminal;
  221. VAR C : char;
  222. BEGIN
  223.    writeln('Use ctrl-E to exit terminal mode.');
  224.    repeat
  225.       IF SerialChar THEN
  226.       begin
  227.          c := Receive;
  228.          {Ansi_Write( c );}
  229.          Write(Screen, c);
  230.       end;
  231.       IF keypressed THEN
  232.       BEGIN
  233.          c := readkey;
  234.          send(c);
  235.       END;
  236.    until (c = ^E);
  237. END;
  238.  
  239. procedure BaudChange;
  240. begin
  241.    write(Screen,'Enter Baud: ');
  242.    Readln(baudrate);
  243.    SetBaudRate(baudrate);
  244. end;
  245.  
  246. PROCEDURE GetOption;
  247. BEGIN
  248.   Writeln('Options:');
  249.   Writeln;
  250.   Writeln('  B - BaudRate');
  251.   Writeln('  H - hang up the phone');
  252.   WriteLn('  P - Com Port');
  253.   Writeln('  R - receive a file');
  254.   Writeln('  S - send a file');
  255.   Writeln;
  256.   Writeln('  T - terminal mode');
  257.   Writeln('  X - exit to system');
  258.   Writeln;
  259.   Write('which ? ');
  260.   REPEAT
  261.     option := Upcase(readkey);
  262.   UNTIL option IN ['B','H','P','R','S','T','X'];
  263.   Writeln(option);
  264. END;
  265.  
  266.  
  267. BEGIN { Modem7 }
  268.   PortNum := 1;
  269.   If not OpenFossil then
  270.   begin
  271.       writeln('Fossil not installed or problem initializing.');
  272.       Halt;
  273.   end;
  274.   Assign(Screen,'');
  275.   Rewrite(Screen);
  276.   baudrate := 19200;
  277.   SetBaudRate(baudrate);
  278.   return := 'N';
  279.   REPEAT
  280.       GetOption;
  281.       CASE option OF
  282.         'B': BaudChange;
  283.         'H': HangUpPhone;
  284.         'P': PortChange;
  285.         'R': ReceiveFile;
  286.         'S': SendFile;
  287.         'T': Terminal;
  288.         'X': return := 'Y';
  289.       END;
  290.   UNTIL return = 'Y';
  291.   CloseFossil;
  292.   Close(Screen);
  293. END.
  294.